home *** CD-ROM | disk | FTP | other *** search
/ Delphi Informant Complete 1995 - 2000 / Delphi Informant Complete 1995 to 2000.iso / Delphi Informant Magazine Complete Works SOURCE CODE 1998.rar / 1998 / Sep / di9809rs / LINEARF.PAS < prev    next >
Pascal/Delphi Source File  |  1998-03-03  |  5KB  |  187 lines
  1. unit LinearF;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  7.   StdCtrls, ExtCtrls;
  8.  
  9. type
  10.   TLinearForm = class(TForm)
  11.     CmdGo: TButton;
  12.     DrawBox: TPaintBox;
  13.     procedure FormResize(Sender: TObject);
  14.     procedure DrawBoxPaint(Sender: TObject);
  15.     procedure CmdGoClick(Sender: TObject);
  16.     procedure DrawBoxMouseUp(Sender: TObject; Button: TMouseButton;
  17.       Shift: TShiftState; X, Y: Integer);
  18.     procedure FormCreate(Sender: TObject);
  19.   private
  20.     { Private declarations }
  21.     procedure DrawPoint(i : Integer);
  22.  
  23.   public
  24.     { Public declarations }
  25.   end;
  26.  
  27. procedure LeastSquares(PtX, PtY : array of Integer;
  28.     NumPts, max_x, max_y : Integer;
  29.     var x1, y1, x2, y2 : Integer);
  30.  
  31. var
  32.   LinearForm: TLinearForm;
  33.  
  34. implementation
  35.  
  36. {$R *.DFM}
  37.  
  38. var
  39.     NumPts, X1, Y1, X2, Y2 : Integer;
  40.     PtX, PtY               : array [0..100] of Integer;
  41.     first_point            : Boolean;
  42.  
  43. // Make DrawBox as big as possible.
  44. procedure TLinearForm.FormResize(Sender: TObject);
  45. const
  46.     GAP = 3;
  47. var
  48.     hgt : Integer;
  49. begin
  50.     if (WindowState = wsMinimized) then Exit;
  51.  
  52.     hgt := ClientHeight - CmdGo.Height - 3 * GAP;
  53.     if (hgt < 10) then hgt := 10;
  54.     DrawBox.Left := GAP;
  55.     DrawBox.Top := GAP;
  56.     DrawBox.Width := ClientWidth - 2 * GAP;
  57.     DrawBox.Height := hgt;
  58.     CmdGo.Left := (ClientWidth - CmdGo.Width) Div 2;
  59.     CmdGo.Top := hgt + 2 * GAP;
  60.  
  61.     DrawBox.Canvas.Refresh;
  62. end;
  63.  
  64. // Draw the points and the linear least squares line.
  65. procedure TLinearForm.DrawBoxPaint(Sender: TObject);
  66. const
  67.     GAP = 2;
  68. var
  69.     i : Integer;
  70. begin
  71.     for i := 1 to NumPts do
  72.     begin
  73.         DrawPoint(i);
  74.     end;
  75.  
  76.     // If we have a least squares line, draw it.
  77.     if (X1 >= 0) then
  78.     begin
  79.         DrawBox.Canvas.MoveTo(X1, Y1);
  80.         DrawBox.Canvas.LineTo(X2, Y2);
  81.     end;
  82. end;
  83.  
  84. // Draw the line and reset the points.
  85. procedure TLinearForm.CmdGoClick(Sender: TObject);
  86. begin
  87.     // Calculate the least squares line.
  88.     LeastSquares(PtX, PtY, NumPts,
  89.         DrawBox.ClientWidth - 1, DrawBox.ClientHeight - 1,
  90.         X1, Y1, X2, Y2);
  91.  
  92.     // Draw the line.
  93.     first_point := True;
  94.     DrawBox.Invalidate;
  95.     CmdGo.Enabled := False;
  96. end;
  97.  
  98. // Draw a small box for the point.
  99. procedure TLinearForm.DrawPoint(i : Integer);
  100. const
  101.     GAP = 2;
  102. begin
  103.     DrawBox.Canvas.Rectangle(
  104.         PtX[i] - GAP, PtY[i] - GAP,
  105.         PtX[i] + GAP, PtY[i] + GAP);
  106. end;
  107.  
  108. // Save this point.
  109. procedure TLinearForm.DrawBoxMouseUp(Sender: TObject; Button: TMouseButton;
  110.   Shift: TShiftState; X, Y: Integer);
  111. begin
  112.     // If this is the first point, reset everything.
  113.     if (first_point) then
  114.     begin
  115.         NumPts := 0; // We have no points.
  116.         X1 := -1;    // We have no least squares line.
  117.         DrawBox.Invalidate;   // Erase everything.
  118.         first_point := False; // We have our first point.
  119.     end;
  120.  
  121.     if (NumPts < 100) then NumPts := NumPts + 1;
  122.     PtX[NumPts] := X;
  123.     PtY[NumPts] := Y;
  124.  
  125.     // Plot the point.
  126.     DrawPoint(NumPts);
  127.  
  128.     // Enable the command button if
  129.     // there are at least two points.
  130.     CmdGo.Enabled := (NumPts > 1);
  131. end;
  132.  
  133. procedure TLinearForm.FormCreate(Sender: TObject);
  134. begin
  135.     // Indicate we need to get the first point.
  136.     first_point := True;
  137.  
  138.     // Indicate we do not have a least squares line yet.
  139.     X1 := -1;
  140. end;
  141.  
  142. // Find the least squares line.
  143. procedure LeastSquares(PtX, PtY : array of Integer;
  144.     NumPts, max_x, max_y : Integer;
  145.     var x1, y1, x2, y2 : Integer);
  146. var
  147.     S1, Sx, Sy, Sxx, Sxy, m, b : Single;
  148.     i                          : Integer;
  149. begin
  150.     // Calculate the least squares sums.
  151.     S1 := 0;
  152.     Sx := 0;
  153.     Sy := 0;
  154.     Sxx := 0;
  155.     Sxy := 0;
  156.     for i := 1 to NumPts do
  157.     begin
  158.         S1 := S1 + 1;
  159.         Sx := Sx + PtX[i];
  160.         Sy := Sy + PtY[i];
  161.         Sxx := Sxx + PtX[i] * PtX[i];
  162.         Sxy := Sxy + PtX[i] * PtY[i];
  163.     end;
  164.  
  165.     // Make sure the line isn't vertical.
  166.     if ((S1 * Sxx - Sx * Sx) = 0) then
  167.     begin
  168.         x1 := PtX[1];
  169.         x2 := x1;
  170.         y1 := 0;
  171.         y2 := max_y;
  172.     end else
  173.     begin
  174.         // Calculate m and b.
  175.         m := (S1 * Sxy - Sx * Sy) / (S1 * Sxx - Sx * Sx);
  176.         b := (Sxx * Sy - Sx * Sxy) / (S1 * Sxx - Sx * Sx);
  177.  
  178.         // Calculate the line's end points.
  179.         x1 := 0;
  180.         y1 := Round(m * x1 + b);
  181.         x2 := max_x;
  182.         y2 := Round(m * x2 + b);
  183.     end;
  184. end;
  185.  
  186. end.
  187.